home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Runtime (.scm & .s) / _system.scm < prev    next >
Encoding:
Text File  |  1992-09-23  |  21.5 KB  |  604 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; System procedures
  6.  
  7. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8.  
  9. (define-system (##type x))
  10. (define-system (##type-cast x y))
  11. (define-system (##subtype x))
  12. (define-system (##subtype-set! x y))
  13.  
  14. (define-system (##unassigned? x)
  15.   (##eq? x ##unass-object))
  16.  
  17. (define-system (##unbound? x)
  18.   (##eq? x ##unbound-object))
  19.  
  20. (define-system (##fixnum? x)
  21.   (##eq? (##type x) (type-fixnum)))
  22.  
  23. (define-system (##special? x)
  24.   (##eq? (##type x) (type-special)))
  25.  
  26. (define-system (##subtyped? x)
  27.   (##eq? (##type x) (type-subtyped)))
  28.  
  29. (define-system (##placeholder? x)
  30.   (##eq? (##type x) (type-placeholder)))
  31.  
  32. (define-system (##ratnum? x)
  33.   (and (##subtyped? x)
  34.        (##eq? (##subtype x) (subtype-ratnum))))
  35.  
  36. (define-system (##cpxnum? x)
  37.   (and (##subtyped? x)
  38.        (##eq? (##subtype x) (subtype-cpxnum))))
  39.  
  40. (define-system (##bignum? x)
  41.   (and (##subtyped? x)
  42.        (##eq? (##subtype x) (subtype-bignum))))
  43.  
  44. (define-system (##flonum? x)
  45.   (and (##subtyped? x)
  46.        (##eq? (##subtype x) (subtype-flonum))))
  47.  
  48. (define-system (##vector-shrink! x y))
  49.  
  50. (define-system (##string-shrink! x y)
  51.   (##vector8-shrink x y))
  52.  
  53. (define-system (##make-vector8 x y)
  54.   (##make-string x (##type-cast y (type-special))))
  55.  
  56. (define-system (##vector8-length x)
  57.   (##string-length x))
  58.  
  59. (define-system (##vector8-ref x y)
  60.   (##type-cast (##string-ref x y) (type-fixnum)))
  61.  
  62. (define-system (##vector8-set! x y z)
  63.   (##string-set! x y (##type-cast z (type-special))))
  64.  
  65. (define-system (##vector8-shrink! x y)
  66.   (##string-shrink x y))
  67.  
  68. (define-system (##make-vector16 x y)
  69.   (let ((v (##make-vector8 (##fixnum.* x 2) 0)))
  70.     (let loop ((i (##fixnum.- x 1)))
  71.       (if (##not (##fixnum.< i 0))
  72.         (begin
  73.           (##vector16-set! v i y)
  74.           (loop (##fixnum.- i 1)))))
  75.     v))
  76.  
  77. (define-system (##vector16-length x)
  78.   (##fixnum.quotient (##vector8-length x) 2))
  79.  
  80. (define-system (##vector16-ref x y)
  81.   (let ((i (##fixnum.* y 2)))
  82.     (##fixnum.+ (##fixnum.* (##vector8-ref x i) 256)
  83.                 (##vector8-ref x (##fixnum.+ i 1)))))
  84.  
  85. (define-system (##vector16-set! x y z)
  86.   (let ((i (##fixnum.* y 2)))
  87.     (##vector8-set! x i (##fixnum.quotient z 256))
  88.     (##vector8-set! x (##fixnum.+ i 1) (##fixnum.modulo z 256))))
  89.  
  90. (define-system (##vector16-shrink! x y)
  91.   (##vector8-shrink x (##fixnum.* y 2)))
  92.  
  93. (define-system (##slot-ref x y))
  94.  
  95. (define-system (##slot-set! x y z))
  96.  
  97. (define-system (##pstate))
  98.  
  99. (define-system (##make-cell x)
  100.   (##cons x '()))
  101.  
  102. (define-system (##cell-ref x)
  103.   (##car x))
  104.  
  105. (define-system (##cell-set! x y)
  106.   (##set-car! x y))
  107.  
  108. (define-system (##touch x))
  109.  
  110. (define-system (##startup)
  111.   (let loop ((i 1))
  112.     (let ((ev ##exec-vector))
  113.       (let ((len (##vector-length ev)))
  114.         (if (##fixnum.< i len)
  115.           (if (##fixnum.= i (##fixnum.- len 1))
  116.             ((##vector-ref ev i))
  117.             (begin
  118.               ((##vector-ref ev i))
  119.               (loop (##fixnum.+ i 1)))))))))
  120.  
  121. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  122.  
  123. ; SPECIAL objects
  124.  
  125. (define ##undef-object   (##type-cast (data-undef)   (type-special)))
  126. (define ##unass-object   (##type-cast (data-unass)   (type-special)))
  127. (define ##unbound-object (##type-cast (data-unbound) (type-special)))
  128. (define ##eof-object     (##type-cast (data-eof)     (type-special)))
  129.  
  130. (define ##unprint-object ##undef-object)
  131.  
  132. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  133.  
  134. ; Variants of standard procedures.
  135.  
  136. ; Most of these procedures do not touch their arguments and are mostly
  137. ; of fixed arity.
  138.  
  139. (define-system (##not x)
  140.   (if x #f #t))
  141.  
  142. ; ##eqv? is defined in "_numbers.scm"
  143.  
  144. (define-system (##eq? x y))
  145.  
  146. (define-system (##equal? x y touch?)
  147.  
  148.   (define (vector8=? x y)
  149.     (let ((len (##vector8-length x)))
  150.       (if (##eq? len (##vector8-length y))
  151.         (let loop ((i (##fixnum.- len 1)))
  152.           (cond ((##fixnum.< i 0)
  153.                  #t)
  154.                 ((##eq? (##vector8-ref x i) (##vector8-ref y i))
  155.                  (loop (##fixnum.- i 1)))
  156.                 (else
  157.                  #f)))
  158.         #f)))
  159.  
  160.   (define (equal x y)
  161.  
  162.     (define (vector=? x y)
  163.       (let ((len (##vector-length x)))
  164.         (if (##eq? len (##vector-length y))
  165.           (let loop ((i (##fixnum.- len 1)))
  166.             (cond ((##fixnum.< i 0)
  167.                   #t)
  168.                   ((equal (##vector-ref x i) (##vector-ref y i))
  169.                    (loop (##fixnum.- i 1)))
  170.                   (else
  171.                    #f)))
  172.           #f)))
  173.  
  174.     (cond ((##eq? x y)
  175.            #t)
  176.           ((##pair? x)
  177.            (and (##pair? y)
  178.                 (equal (##car x) (##car y))
  179.                 (equal (##cdr x) (##cdr y))))
  180.           ((##symbol? x)
  181.            #f)
  182.           ((##subtyped? x)
  183.            (and (##subtyped? y)
  184.                 (let ((tag (##subtype x)))
  185.                   (if (##eq? tag (##subtype y))
  186.                     (if (subtype-ovector? tag)
  187.                       (vector=? x y)
  188.                       (vector8=? x y))
  189.                     #f))))
  190.           (else
  191.            #f)))
  192.  
  193.   (define (equal* x y)
  194.  
  195.     (define (vector=? x y)
  196.       (let ((len (##vector-length x)))
  197.         (if (##eq? len (##vector-length y))
  198.           (let loop ((i (##fixnum.- len 1)))
  199.             (cond ((##fixnum.< i 0)
  200.                   #t)
  201.                   ((equal* (##vector-ref x i) (##vector-ref y i))
  202.                    (loop (##fixnum.- i 1)))
  203.                   (else
  204.                    #f)))
  205.           #f)))
  206.  
  207.     (let ((x (##touch x)) (y (##touch y)))
  208.       (cond ((##eq? x y)
  209.              #t)
  210.             ((##pair? x)
  211.              (and (##pair? y)
  212.                   (equal* (##car x) (##car y))
  213.                   (equal* (##cdr x) (##cdr y))))
  214.             ((##symbol? x)
  215.              #f)
  216.             ((##subtyped? x)
  217.              (and (##subtyped? y)
  218.                   (let ((tag (##subtype x)))
  219.                     (if (##eq? tag (##subtype y))
  220.                       (if (subtype-ovector? tag)
  221.                         (vector=? x y)
  222.                         (vector8=? x y))
  223.                       #f))))
  224.             (else
  225.              #f))))
  226.  
  227.   (if touch?
  228.     (equal* x y)
  229.     (equal x y)))
  230.  
  231. (define-system (##pair? x))
  232.  
  233. (define-system (##cons x y))
  234.  
  235. (define-system (##set-car! x y))
  236.  
  237. (define-system (##set-cdr! x y))
  238.  
  239. (define-system (##car x))
  240.  
  241. (define-system (##cdr x))
  242.  
  243. (##define-macro (define-c...r name pattern)
  244.  
  245.   (define (gen name pattern)
  246.     (if (<= pattern 3)
  247.        (if (= pattern 3) '(##CDR X) '(##CAR X))
  248.        (let ((x (gen name (quotient pattern 2))))
  249.          (if (odd? pattern) '(##CDR ,x) '(##CAR ,x)))))
  250.  
  251.   `(DEFINE-SYSTEM (,name X)
  252.      ,(gen name pattern)))
  253.  
  254. (define-c...r ##caar 4)
  255. (define-c...r ##cadr 5)
  256. (define-c...r ##cdar 6)
  257. (define-c...r ##cddr 7)
  258. (define-c...r ##caaar 8)
  259. (define-c...r ##caadr 9)
  260. (define-c...r ##cadar 10)
  261. (define-c...r ##caddr 11)
  262. (define-c...r ##cdaar 12)
  263. (define-c...r ##cdadr 13)
  264. (define-c...r ##cddar 14)
  265. (define-c...r ##cdddr 15)
  266. (define-c...r ##caaaar 16)
  267. (define-c...r ##caaadr 17)
  268. (define-c...r ##caadar 18)
  269. (define-c...r ##caaddr 19)
  270. (define-c...r ##cadaar 20)
  271. (define-c...r ##cadadr 21)
  272. (define-c...r ##caddar 22)
  273. (define-c...r ##cadddr 23)
  274. (define-c...r ##cdaaar 24)
  275. (define-c...r ##cdaadr 25)
  276. (define-c...r ##cdadar 26)
  277. (define-c...r ##cdaddr 27)
  278. (define-c...r ##cddaar 28)
  279. (define-c...r ##cddadr 29)
  280. (define-c...r ##cdddar 30)
  281. (define-c...r ##cddddr 31)
  282.  
  283. (define-system (##weak-pair? x))
  284. (define-system (##weak-cons x y))
  285. (define-system (##weak-set-car! x y))
  286. (define-system (##weak-set-cdr! x y))
  287. (define-system (##weak-car x))
  288. (define-system (##weak-cdr x))
  289.  
  290. (define-system (##null? x)
  291.   (##eq? x '()))
  292.  
  293. (define-system (##list . l)
  294.   l)
  295.  
  296. (define-system (##length l)
  297.   (let loop ((l l) (n 0))
  298.     (if (##pair? l)
  299.       (loop (##cdr l) (##fixnum.+ n 1))
  300.       n)))
  301.  
  302. (define-system (##append l1 l2)
  303.   (if (##pair? l1)
  304.     (let ((result (##cons (##car l1) '())))
  305.       (##set-cdr!
  306.         (let loop ((end result) (l1 (##cdr l1)))
  307.           (if (##pair? l1)
  308.             (let ((tail (##cons (##car l1) '())))
  309.               (##set-cdr! end tail)
  310.               (loop tail (##cdr l1)))
  311.             end))
  312.         l2)
  313.       result)
  314.     l2))
  315.  
  316. (define-system (##reverse l)
  317.   (let loop ((l l) (x '()))
  318.     (if (##pair? l)
  319.       (loop (##cdr l) (##cons (##car l) x))
  320.       x)))
  321.  
  322. (define-system (##memq x l)
  323.   (let loop ((l l))
  324.     (if (##pair? l)
  325.       (if (##eq? x (##car l))
  326.         l
  327.         (loop (##cdr l)))
  328.       #f)))
  329.  
  330. (define-system (##assq x l)
  331.   (let loop ((y l))
  332.     (if (##pair? y)
  333.       (let ((couple (##car y)))
  334.         (if (##eq? x (##car couple))
  335.           couple
  336.           (loop (##cdr y))))
  337.         #f)))
  338.  
  339. (define-system (##symbol? x)
  340.   (and (##subtyped? x)
  341.        (##eq? (##subtype x) (subtype-symbol))))
  342.  
  343. (define-system (##symbol->string sym)
  344.   (symbol-string sym))
  345.  
  346. (define-system (##string->symbol str)
  347.  
  348.   (define (hash str n)
  349.     (let ((len (##string-length str)))
  350.       (let loop ((h 0) (i 0))
  351.         (if (##not (##fixnum.< i len))
  352.           h
  353.           (let ((x (##fixnum.+ (##fixnum.* h 256)
  354.                                (##type-cast (##string-ref str i)
  355.                                             (type-fixnum)))))
  356.             (loop (##fixnum.remainder x n) (##fixnum.+ i 1)))))))
  357.  
  358.   (let ((h (hash str (##vector-length ##symbol-table))))
  359.     (let loop ((l (##vector-ref ##symbol-table h)))
  360.       (cond ((##not (##pair? l))
  361.              (let ((sym (symbol-make (##string-copy str))))
  362.                (##vector-set! ##symbol-table h
  363.                  (##cons sym (##vector-ref ##symbol-table h)))
  364.                sym))
  365.             ((##string=? (symbol-string (##car l)) str)
  366.              (##car l))
  367.             (else
  368.              (loop (##cdr l)))))))
  369.  
  370. (define-system (##string->uninterned-symbol str)
  371.   (symbol-make (##string-copy str)))
  372.  
  373. ; numeric procedures are in "_numbers.scm"
  374.  
  375. (define-system (##char? x)
  376.   (and (##eq? (##type x) (type-special))
  377.        (let ((y (##type-cast x (type-fixnum))))
  378.          (and (##fixnum.< 0 y) (##fixnum.< y (char-range))))))
  379.  
  380. (define-nary0-boolean (##char=? x y)
  381.   (##eq? x y) no-check no-touch)
  382.  
  383. (define-nary0-boolean (##char<? x y)
  384.   (##char<? x y) no-check no-touch)
  385.  
  386. (define-nary0-boolean (##char>? x y)
  387.   (##char<? y x) no-check no-touch)
  388.  
  389. (define-nary0-boolean (##char<=? x y)
  390.   (##not (##char<? y x)) no-check no-touch)
  391.  
  392. (define-nary0-boolean (##char>=? x y)
  393.   (##not (##char<? x y)) no-check no-touch)
  394.  
  395. (define-nary0-boolean (##char-ci=? x y)
  396.   (##char=? (##char-downcase x) (##char-downcase y)) no-check no-touch)
  397.  
  398. (define-nary0-boolean (##char-ci<? x y)
  399.   (##char<? (##char-downcase x) (##char-downcase y)) no-check no-touch)
  400.  
  401. (define-nary0-boolean (##char-ci>? x y)
  402.   (##char<? (##char-downcase y) (##char-downcase x)) no-check no-touch)
  403.  
  404. (define-nary0-boolean (##char-ci<=? x y)
  405.   (##not (##char<? (##char-downcase y) (##char-downcase x))) no-check no-touch)
  406.  
  407. (define-nary0-boolean (##char-ci>=? x y)
  408.   (##not (##char<? (##char-downcase x) (##char-downcase y))) no-check no-touch)
  409.  
  410. (define-system (##char-alphabetic? c)
  411.   (let ((x (##char-downcase c)))
  412.     (and (##not (##char<? x #\a)) (##not (##char<? #\z x)))))
  413.  
  414. (define-system (##char-numeric? c)
  415.   (and (##not (##char<? c #\0)) (##not (##char<? #\9 c))))
  416.  
  417. (define-system (##char-whitespace? c)
  418.   (char-whitespace c))
  419.  
  420. (define-system (##char-upper-case? c)
  421.   (and (##not (##char<? c #\A)) (##not (##char<? #\Z c))))
  422.  
  423. (define-system (##char-lower-case? c)
  424.   (and (##not (##char<? c #\a)) (##not (##char<? #\z c))))
  425.  
  426. (define-system (##char->integer c)
  427.   (##type-cast c (type-fixnum)))
  428.  
  429. (define-system (##integer->char n)
  430.   (##type-cast n (type-special)))
  431.  
  432. (define-system (##char-upcase c)
  433.   (if (and (##not (##char<? c #\a)) (##not (##char<? #\z c)))
  434.     (##type-cast (##fixnum.- (##type-cast c (type-fixnum)) (char-up-to-down))
  435.                  (type-special))
  436.     c))
  437.  
  438. (define-system (##char-downcase c)
  439.   (if (and (##not (##char<? c #\A)) (##not (##char<? #\Z c)))
  440.     (##type-cast (##fixnum.+ (##type-cast c (type-fixnum)) (char-up-to-down))
  441.                  (type-special))
  442.     c))
  443.  
  444. (define-system (##string? x)
  445.   (and (##subtyped? x)
  446.        (##eq? (##subtype x) (subtype-string))))
  447.  
  448. (define-system (##make-string x y)
  449.   (##make-vector8 x (##type-cast y (type-fixnum))))
  450.  
  451. (define-system (##string-length str)
  452.   (##vector8-length str))
  453.  
  454. (define-system (##string-ref str i)
  455.   (##type-cast (##vector8-ref str i) (type-special)))
  456.  
  457. (define-system (##string-set! str i c)
  458.   (##vector8-set! str i (##type-cast c (type-fixnum))))
  459.  
  460. (define-system (##string=? x y)
  461.   (let ((len (##string-length x)))
  462.     (if (##eq? len (##string-length y))
  463.       (let loop ((i (##fixnum.- len 1)))
  464.         (cond ((##fixnum.< i 0)
  465.                #t)
  466.               ((##char=? (##string-ref x i) (##string-ref y i))
  467.                (loop (##fixnum.- i 1)))
  468.               (else
  469.                #f)))
  470.       #f)))
  471.  
  472. (define-system (##string<? x y)
  473.   (let ((lx (##string-length x))
  474.         (ly (##string-length y)))
  475.     (let ((n (if (##fixnum.< lx ly) lx ly)))
  476.       (let loop ((i 0))
  477.         (if (##fixnum.< i n)
  478.           (let ((cx (##string-ref x i))
  479.                 (cy (##string-ref y i)))
  480.             (if (##char=? cx cy)
  481.               (loop (##fixnum.+ i 1))
  482.               (##char<? cx cy)))
  483.           (##fixnum.< n ly))))))
  484.  
  485. (define-system (##string>? x y)
  486.   (##string<? y x))
  487.  
  488. (define-system (##string<=? x y)
  489.   (##not (##string<? y x)))
  490.  
  491. (define-system (##string>=? x y)
  492.   (##not (##string<? x y)))
  493.  
  494. (define-system (##string-ci=? x y)
  495.   (let ((len (##string-length x)))
  496.     (if (##eq? len (##string-length y))
  497.       (let loop ((i (##fixnum.- len 1)))
  498.         (cond ((##fixnum.< i 0)
  499.                #t)
  500.               ((##char=? (##char-downcase (##string-ref x i))
  501.                          (##char-downcase (##string-ref y i)))
  502.                (loop (##fixnum.- i 1)))
  503.               (else
  504.                #f)))
  505.       #f)))
  506.  
  507. (define-system (##string-ci<? x y)
  508.   (let ((lx (##string-length x))
  509.         (ly (##string-length y)))
  510.     (let ((n (if (##fixnum.< lx ly) lx ly)))
  511.       (let loop ((i 0))
  512.         (if (##fixnum.< i n)
  513.           (let ((cx (##char-downcase (##string-ref x i)))
  514.                 (cy (##char-downcase (##string-ref y i))))
  515.             (if (##char=? cx cy)
  516.               (loop (##fixnum.+ i 1))
  517.               (##char<? cx cy)))
  518.           (##fixnum.< n ly))))))
  519.  
  520. (define-system (##string-ci>? x y)
  521.   (##string-ci<? y x))
  522.  
  523. (define-system (##string-ci<=? x y)
  524.   (##not (##string-ci<? y x)))
  525.  
  526. (define-system (##string-ci>=? x y)
  527.   (##not (##string-ci<? x y)))
  528.  
  529. (define-system (##substring x y z)
  530.   (let* ((n (##fixnum.- z y))
  531.          (result (##make-string n #\space)))
  532.     (let loop ((i (##fixnum.- n 1)))
  533.       (if (##not (##fixnum.< i 0))
  534.         (begin
  535.           (##string-set! result i (##string-ref x (##fixnum.+ y i)))
  536.           (loop (##fixnum.- i 1)))))
  537.     result))
  538.  
  539. (define-system (##string-append . l)
  540.   (let loop1 ((n 0) (x l) (y '()))
  541.     (if (##pair? x)
  542.       (let ((s (##car x)))
  543.         (loop1 (##fixnum.+ n (##string-length s)) (##cdr x) (##cons s y)))
  544.       (let ((result (##make-string n #\space)))
  545.         (let loop2 ((k (##fixnum.- n 1)) (y y))
  546.           (if (##pair? y)
  547.             (let ((s (##car y)))
  548.               (let loop3 ((i k) (j (##fixnum.- (##string-length s) 1)))
  549.                 (if (##not (##fixnum.< j 0))
  550.                   (begin
  551.                     (##string-set! result i (##string-ref s j))
  552.                     (loop3 (##fixnum.- i 1) (##fixnum.- j 1)))
  553.                   (loop2 i (##cdr y)))))
  554.             result))))))
  555.  
  556. (define-system (##vector? x)
  557.   (and (##subtyped? x)
  558.        (##eq? (##subtype x) (subtype-vector))))
  559.  
  560. (define-system (##make-vector x y))
  561.  
  562. (define-system (##vector-length vect))
  563.  
  564. (define-system (##vector-ref str i))
  565.  
  566. (define-system (##vector-set! str i c))
  567.  
  568. (define-system (##procedure? x)
  569.   (##eq? (##type x) (type-procedure)))
  570.  
  571. (define-system (##apply p l))
  572.  
  573. (define-system (##call-with-current-continuation p))
  574.  
  575. ; input/output procedures are in "ports.scm"
  576.  
  577. (define-system (##string-copy str)
  578.   (let* ((n (##string-length str))
  579.          (result (##make-string n #\space)))
  580.     (let loop ((i (##fixnum.- n 1)))
  581.       (if (##fixnum.< i 0)
  582.         result
  583.         (begin
  584.           (##string-set! result i (##string-ref str i))
  585.           (loop (##fixnum.- i 1)))))))
  586.  
  587. (define-system (##vector->list vect)
  588.   (let loop ((l '()) (i (##fixnum.- (##vector-length vect) 1)))
  589.     (if (##fixnum.< i 0)
  590.       l
  591.       (loop (##cons (##vector-ref vect i) l) (##fixnum.- i 1)))))
  592.  
  593. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  594.  
  595. ; Procedures for front end
  596.  
  597. (define-system (##quasi-append x y)
  598.   (touch-vars (x)
  599.     (if (##pair? x)
  600.       (let ((result (##cons (##car x) '())))
  601.         (##set-cdr!
  602.           (let loop ((end result) (x (##cdr x)))
  603.             (touch-vars (x)
  604.               (if (##pair? x